collect (list i b1 b2))
nil)
+(deftest read-byte.5
+ (let ((s (open "foo.txt"
+ :direction :output
+ :if-exists :supersede
+ :element-type '(unsigned-byte 8))))
+ (values
+ (write-byte 255 s)
+ (close s)
+ (progn
+ (setq s (open "foo.txt"
+ :direction :input
+ :element-type '(signed-byte 8)))
+ (read-byte s))
+ (close s)))
+ 255 t -1 t)
+
;;; Error tests
(deftest read-byte.error.1
(make-array 10 :initial-element nil :fill-pointer 5)
(:end nil) "abcdefghijk" 5 #(#\a #\b #\c #\d #\e))
+;; Fast read-sequence
+
+(def-read-sequence-test read-sequence.fast-char.1
+ (make-array 5 :element-type 'character)
+ (:end nil) "abcdefghijk" 5 "abcde")
+
;;; Nil vectors
(deftest read-sequence.nil-vector.1
(def-read-sequence-bv-test read-sequence.bv.7 #*00000000000000 (:end 6)
6 #*01100100000000)
+;; Fast read-sequence -> fread cases
+
+(defmacro def-read-sequence-fread-test (name seql tp data args &rest expected)
+ `(deftest ,name
+ ;; Create output file
+ (progn
+ (let (os)
+ (unwind-protect
+ (progn
+ (setq os (open "temp.dat" :direction :output
+ :element-type ',tp
+ :if-exists :supersede))
+ (loop for i in (coerce ,data 'list)
+ do (if (eq ',tp 'character) (write-char i os) (write-byte i os))))
+ (when os (close os))))
+ (let (is (seq (make-array ,seql :element-type ',tp)))
+ (unwind-protect
+ (progn
+ (setq is (open "temp.dat" :direction :input
+ :element-type ',tp))
+ (values
+ (read-sequence seq is ,@args)
+ seq))
+ (when is (close is)))))
+ ,@expected))
+
+(def-read-sequence-fread-test
+ read-sequence.fread.1 20
+ character "abcdefghijk" ()
+ 11 "abcdefghijk ")
+
+(def-read-sequence-fread-test
+ read-sequence.fread.2 20
+ character "abcdefghijk" (:start 1)
+ 12 " abcdefghijk ")
+
+(def-read-sequence-fread-test
+ read-sequence.fread.3 20
+ character "abcdefghijk" (:start 1 :end 3)
+ 3 " ab ")
+
+(def-read-sequence-fread-test
+ read-sequence.fread.4 20
+ character "abcdefghijk" (:end 3)
+ 3 "abc ")
+
+(def-read-sequence-fread-test
+ read-sequence.fread.5 20
+ fixnum #(1 2 3 4 5 6 7 8 9 10 11) (:end 3)
+ 3 #(1 2 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
+
+(def-read-sequence-fread-test
+ read-sequence.fread.6 20
+ (unsigned-byte 16) #(1 2 3 4 5 6 7 8 9 10 11) (:start 2 :end 6)
+ 6 #(0 0 1 2 3 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
+
+
;;; Error cases
(deftest read-sequence.error.1
(defmacro def-write-sequence-bv-test (name input args expected)
`(deftest ,name
- (let ((s ,input)
- (expected ,expected))
- (with-open-file
- (os "tmp.dat" :direction :output
- :element-type '(unsigned-byte 8)
- :if-exists :supersede)
- (assert (eq (write-sequence s os ,@args) s)))
- (with-open-file
- (is "tmp.dat" :direction :input
- :element-type '(unsigned-byte 8))
- (loop for i from 0 below (length expected)
- for e = (elt expected i)
- always (eql (read-byte is) e))))
+ (let ((s ,input)
+ (expected ,expected))
+ (with-open-file
+ (os "tmp.dat" :direction :output
+ :element-type '(unsigned-byte 8)
+ :if-exists :supersede)
+ (assert (eq (write-sequence s os ,@args) s)))
+ (with-open-file
+ (is "tmp.dat" :direction :input
+ :element-type '(unsigned-byte 8))
+ (loop for i from 0 below (length expected)
+ for e = (elt expected i)
+ always (eql (read-byte is) e))))
t))
(def-write-sequence-bv-test write-sequence.bv.1 #*00111010
(def-write-sequence-bv-test write-sequence.bv.6 #*00111010
(:start 1 :end nil :end 4) #*0111010)
+(defmacro def-write-sequence-tp-test (name tp input args expected)
+ `(deftest ,name
+ (let ((s (coerce ',input `(vector ,',tp)))
+ (expected ',expected))
+ (with-open-file
+ (os "tmp.dat" :direction :output
+ :element-type ',tp
+ :if-exists :supersede)
+ (assert (eq (write-sequence s os ,@args) s)))
+ (with-open-file
+ (is "tmp.dat" :direction :input
+ :element-type ',tp)
+ (loop for i from 0 below (length expected)
+ for e = (elt expected i)
+ always (eql (if (eq ',tp 'character) (read-char is) (read-byte is)) e))))
+ t))
+
+(def-write-sequence-tp-test write-sequence.tp.1 (unsigned-byte 8)
+ (1 2 3 4 5 6 7 8 9 10) () (1 2 3 4 5 6 7 8 9 10))
+(def-write-sequence-tp-test write-sequence.tp.2 (unsigned-byte 16)
+ (1 2 3 4 5 6 7 8 9 10) () (1 2 3 4 5 6 7 8 9 10))
+(def-write-sequence-tp-test write-sequence.tp.3 (signed-byte 32)
+ (1 2 3 4 5 6 7 8 9 10) () (1 2 3 4 5 6 7 8 9 10))
+(def-write-sequence-tp-test write-sequence.tp.4 (signed-byte 64)
+ (1 2 3 4 5 6 7 8 9 10) () (1 2 3 4 5 6 7 8 9 10))
+(def-write-sequence-tp-test write-sequence.tp.5 (unsigned-byte 128)
+ (1 2 3 4 5 6 7 8 9 10) () (1 2 3 4 5 6 7 8 9 10))
+(def-write-sequence-tp-test write-sequence.tp.6 character
+ (#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\1) () (#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\1))
+(def-write-sequence-tp-test write-sequence.tp.7 (unsigned-byte 16)
+ (1 2 3 4 5 6 7 8 9 10) (:start 1) (2 3 4 5 6 7 8 9 10))
+(def-write-sequence-tp-test write-sequence.tp.8 (unsigned-byte 16)
+ (1 2 3 4 5 6 7 8 9 10) (:end 4) (1 2 3))
+(def-write-sequence-tp-test write-sequence.tp.9 (unsigned-byte 16)
+ (1 2 3 4 5 6 7 8 9 10) (:start 1 :end 4) (2 3))
+(def-write-sequence-tp-test write-sequence.tp.10 (unsigned-byte 16)
+ (1 2 3 4 5 6 7 8 9 10) (:start 1 :end nil :end 4) (2 3 4 5 6 7 8 9 10))
;;; Error tests
(defun stub-decl (name args d &optional vp
&aux (i 0))
- (concatenate
- 'string
+ (ms
"static " d " " name ;" LnkT" num
"("
- (apply 'concatenate 'string
- (mapcan (lambda (x)
- (if (eq x '*)
- (list ",...")
- (list (if (plusp i) "," "")
- (rep-type x)
- (progn (incf i) (if vp (concatenate 'string "x" (write-to-string i)) "")))))
- (if (eq (car args) '*) (cons t args) args)))
+ (mapcan (lambda (x)
+ (if (eq x '*)
+ (list ",...")
+ (list (if (plusp i) "," "")
+ (rep-type x)
+ (progn (incf i) (if vp (list "x" (write-to-string i)) "")))))
+ (if (eq (car args) '*) (cons t args) args))
")"))
(i (max n (- (length args) n)));FIXME
(si (write-to-string i))
(d (declaration-type (rep-type (if (link-arg-p type) type t)))))
- (concatenate
- 'string
+ (ms
(stub-decl (concatenate 'string "LnkT" num) args d t)
"{
int nargs=" (if va "fcall.argd<0 ? -fcall.argd : fcall.argd" si) ";
"
(let ((j 0))
- (apply 'concatenate 'string
- (mapcan (lambda (x &aux (sj (write-to-string (incf j))))
- (declare (ignore x))
- (list "FOO[" sj "-1]=(object)x" sj ";"))
- (make-list i))))
+ (mapcan (lambda (x &aux (sj (write-to-string (incf j))))
+ (declare (ignore x))
+ (list "FOO[" sj "-1]=(object)x" sj ";"))
+ (make-list i)))
(when va
- (concatenate
- 'string
+ (list
"
{
va_list ap;
"FOO);
}"))
+
(defun wt-function-link (x)
(let* ((name (pop x))
(num (pop x))
;(si::putprop 'read-byte 'co1read-byte 'co1)
#-cygwin(si::putprop 'read-char 'co1read-char 'co1)
-(si::putprop 'write-byte 'co1write-byte 'co1)
(si::putprop 'write-char 'co1write-char 'co1)
(defun fast-read (args read-fun)
(declare (type ,(result-type stream) ,str))
,(cfast-write (list (car args) str) write-fun tp)))))))
-
-(defun co1write-byte (f args)
- (declare (ignore f))
- (let ((tem (cfast-write args 'write-byte 'fixnum)))
- (when tem
- (let ((*space* 10))
- (c1expr tem)))))
-
-
(defun co1write-char (f args)
(declare (ignore f))
(let* ((tem (cfast-write args 'write-char 'character)))
(cond (f (setq inl (lit-string-merge inl (fourth f) i lna (1- lff)))
(setq lev (min lev 1));FIXME?
; (when (> lev (seventh f)) (setq lev (seventh f))); (break)
- (incf i lff)(copy-list ff));FIXME?
+ (incf i lff)(incf lna (1- lff))(copy-list ff));FIXME?
((incf i)(list x))))
nargs))
(form (list 'lit info key inl nargs nil lev oargs nil (make-vs info))))
-"Version_2_7_2pre15"
+"Version_2_7_2pre16"
))
-(defun restrict-stream-element-type (tp)
- (cond ((member tp '(unsigned-byte signed-byte)) tp)
- ((or (member tp '(character :default)) (subtypep tp 'character)) 'character)
+(defun encapsulate-stream-element-type (tp)
+ (cond ((subtypep tp 'character) 'character)
((subtypep tp 'integer)
(let* ((ntp (tp-bnds (cmp-norm-tp tp)))
(min (car ntp))(max (cdr ntp))
(s (if (or (eq min '*) (< min 0)) 'signed-byte 'unsigned-byte))
(lim (unless (or (eq min '*) (eq max '*)) (max (integer-length min) (integer-length max))))
(lim (if (and lim (eq s 'signed-byte)) (1+ lim) lim)))
- (if lim `(,s ,lim) s)))
+ (if lim `(,s ,lim) s)))))
+
+(defconstant +array-stream-types+ (coerce (mapcar 'encapsulate-stream-element-type +array-types+) '(vector t)))
+
+(defun restrict-stream-element-type (tp &aux etp);standardize....
+ (cond ((member tp '(:default character)) 'character)
+ ((eq tp 'unsigned-byte) '(unsigned-byte 8))
+ ((eq tp 'signed-byte) '(signed-byte 8))
+ ((typep tp '(cons (member unsigned-byte signed-byte) (cons (integer 0) null)))
+ (let ((tp (list (car tp) (* char-length (ceiling (cadr tp) char-length)))))
+ (or (find tp +array-stream-types+ :test 'equal) tp)))
+ ((subtypep tp 'character) 'character)
+ ((setq etp (encapsulate-stream-element-type tp))
+ (restrict-stream-element-type etp))
((check-type tp (member character integer)))))
+(defun stream-fp (strm outp)
+ (when (open-stream-p strm)
+ (typecase strm
+ (file-synonym-stream (stream-fp (symbol-value (synonym-stream-symbol strm)) outp))
+ (two-way-stream (stream-fp
+ (if outp (two-way-stream-output-stream strm) (two-way-stream-input-stream strm))
+ outp))
+ (file-io-stream (c-stream-fp strm))
+ (file-input-stream (unless outp (c-stream-fp strm)))
+ (file-output-stream (when outp (c-stream-fp strm))))))
+
(defun load-pathname-exists (z)
(or (probe-file z)
(when *allow-gzipped-file*
(declare (optimize (safety 1)))
(parse-integer-int s start end radix junk-allowed))
-(defun write-byte (j s &aux (i j))
+(defun stream-element-type (s)
+ (declare (optimize (safety 1)))
+ (check-type s stream);etypecase
+ (typecase s
+ ((or broadcast-stream concatenated-stream)
+ (let ((o (c-stream-object0 s)))
+ (when o (stream-element-type (car o)))))
+ ((or two-way-stream echo-stream)
+ (stream-element-type (c-stream-object0 s)))
+ (synonym-stream
+ (stream-element-type (symbol-value (c-stream-object0 s))))
+ (file-stream;define socket
+ (c-stream-object0 s))
+ (t 'character)))
+
+(deftype binary-stream-element-type nil 'list)
+(defconstant +char-shft+ (1- (integer-length char-length)))
+
+(defun read-byte (s &optional (eof-error-p t) eof-value &aux (i 0)(tp (stream-element-type s)))
(declare (optimize (safety 1)))
- (check-type j integer)
(check-type s stream)
- (dotimes (k (get-byte-stream-nchars s) j)
- (write-char (code-char (logand i #.(1- (ash 1 char-length)))) s)
- (setq i (ash i #.(- char-length)))))
+ (check-type tp binary-stream-element-type)
+ (let* ((n (if tp (ash (cadr tp) (- +char-shft+)) 1)))
+ (dotimes (k n (let ((nb (ash n +char-shft+)))
+ (if (when (eq (car tp) 'signed-byte) (logbitp (1- nb) i)) (- i (ash 1 nb)) i)))
+ (setq i (logior i (ash (let ((ch (read-char s eof-error-p eof-value)))
+ (if (eq ch eof-value) (return ch) (char-code ch)))
+ (ash k +char-shft+)))))))
+
+(defun write-byte (j s &aux (i j) (tp (stream-element-type s)))
+ (declare (optimize (safety 1)))
+ (check-type j integer)
+ (check-type tp binary-stream-element-type)
+ (let ((n (ash (cadr tp) (- +char-shft+))))
+ (dotimes (k n j)
+ (write-char (code-char (logand i #.(1- (ash 1 char-length)))) s)
+ (setq i (ash i #.(- char-length))))))
+
+#-pre-gcl
+(defdlfun (:fixnum "fread") :fixnum :fixnum :fixnum :fixnum)
+
+(defun read-sequence-using-fread (seq strm tp start end &aux (fp (stream-fp strm nil)))
+ #+pre-gcl
+ (declare (ignore seq tp start end fp))
+ #-pre-gcl
+ (when fp
+ (when (eq tp (aref +array-stream-types+ (c-array-elttype seq)))
+ (let* ((n (ash 1 (1- (c-array-eltsize seq))))(ln (length seq))(end (or end ln)))
+ (when (<= start end ln)
+ (c+ start
+ (|libc|:|fread|
+ (c+ (c-array-self seq) (c* n start)) n (c- end start) fp)))))))
-(defun read-byte (s &optional (eof-error-p t) eof-value &aux (i 0))
- (declare (optimize (safety 1)))
- (check-type s stream)
- (dotimes (k (get-byte-stream-nchars s) i)
- (setq i (logior i (ash (let ((ch (read-char s eof-error-p eof-value)))
- (if (eq ch eof-value) (return ch) (char-code ch)))
- (* k char-length))))))
(defun read-sequence (seq strm &key (start 0) end
&aux (l (listp seq))(seqp (when l (nthcdr start seq)))
- (cp (eq (stream-element-type strm) 'character)))
+ (tp (stream-element-type strm)))
(declare (optimize (safety 1)));FIXME
(check-type seq sequence)
(check-type strm stream)
- (check-type start (integer 0))
- (check-type end (or null (integer 0)))
- (labels ((set-cons (x z) (check-type x cons) (setf (car x) z) (cdr x)))
- (the seqbnd
- (reduce (lambda (y x &aux (z (if cp (read-char strm nil 'eof) (read-byte strm nil 'eof))))
- (declare (seqind y)(ignorable x))
- (when (eq z 'eof) (return-from read-sequence y))
- (if l (setq seqp (set-cons seqp z)) (setf (aref seq y) z))
- (1+ y))
- seq :initial-value start :start start :end end))))
+ (check-type start seqind)
+ (check-type end (or null seqind))
+ (the seqbnd
+ (or (unless l (read-sequence-using-fread seq strm tp start end))
+ (labels ((set-cons (x z) (check-type x cons) (setf (car x) z) (cdr x))
+ (mread nil (if (eq tp 'character) (read-char strm nil 'eof) (read-byte strm nil 'eof))))
+ (reduce (lambda (y x &aux (z (mread)))
+ (declare (seqind y)(ignorable x))
+ (when (eq z 'eof) (return-from read-sequence y))
+ (if l (setq seqp (set-cons seqp z)) (setf (aref seq y) z))
+ (1+ y))
+ seq :initial-value start :start start :end end)))))
+
+#-pre-gcl
+(defdlfun (:fixnum "fwrite") :fixnum :fixnum :fixnum :fixnum)
+
+(defun write-sequence-using-fwrite (seq strm tp start end &aux (fp (stream-fp strm t)))
+ #+pre-gcl
+ (declare (ignore seq tp start end fp))
+ #-pre-gcl
+ (when fp
+ (when (eq tp (aref +array-stream-types+ (c-array-elttype seq)))
+ (let* ((n (ash 1 (1- (c-array-eltsize seq))))(ln (length seq))(end (or end ln)))
+ (when (<= start end ln)
+ (c+ start
+ (|libc|:|fwrite|
+ (c+ (c-array-self seq) (c* n start)) n (c- end start) fp)))))))
(defun write-sequence (seq strm &key (start 0) end
- &aux (cp (eq (stream-element-type strm) 'character)))
+ &aux (tp (stream-element-type strm)))
(declare (optimize (safety 1)))
(check-type seq sequence)
(check-type strm stream)
(check-type start (integer 0))
(check-type end (or null (integer 0)))
- (reduce (lambda (y x)
- (declare (seqind y))
- (if cp (write-char x strm) (write-byte x strm))
- (1+ y))
- seq :initial-value start :start start :end end)
+ (or (unless (listp seq) (write-sequence-using-fwrite seq strm tp start end))
+ (reduce (lambda (y x)
+ (declare (seqind y))
+ (if (eq tp 'character) (write-char x strm) (write-byte x strm))
+ (1+ y))
+ seq :initial-value start :start start :end end))
seq)
(defun open (f &key (direction :input)
if-exists iesp if-does-not-exist idnesp external-format)))
(when (typep s 'stream) (c-set-stream-object1 s pf) s)))
+(defun open-stream-p (strm)
+ (declare (optimize (safety 1)))
+ (check-type strm stream)
+ (not (logbitp #.(let ((s (open "/dev/null")))(close s) (1- (integer-length (c-stream-flags s))))
+ (c-stream-flags strm))))
(defun file-length (x)
(declare (optimize (safety 1)))
check_arg_failed(int n)
{
if (n<vs_top-vs_base)
- FEtoo_few_arguments(vs_base,vs_top);
- else
FEtoo_many_arguments(vs_base,vs_top);
+ else
+ FEtoo_few_arguments(vs_base,vs_top);
}
void
}
}
-static object
-stream_element_type(object strm) {
-
- object x;
-
-BEGIN:
- switch (strm->sm.sm_mode) {
- case smm_input:
- case smm_output:
- case smm_io:
- case smm_probe:
- return(strm->sm.sm_object0);
-
- case smm_socket:
- return (sLcharacter);
-
- case smm_file_synonym:
- case smm_synonym:
- strm = symbol_value(strm->sm.sm_object0);
- if (type_of(strm) != t_stream)
- FEwrong_type_argument(sLstream, strm);
- goto BEGIN;
-
- case smm_broadcast:
- x = strm->sm.sm_object0;
- if (endp(x))
- return(Ct);
- return(stream_element_type(x->c.c_car));
-
- case smm_concatenated:
- x = strm->sm.sm_object0;
- if (endp(x))
- return(Ct);
- return(stream_element_type(x->c.c_car));
-
- case smm_two_way:
- return(stream_element_type(STREAM_INPUT_STREAM(strm)));
-
- case smm_echo:
- return(stream_element_type(STREAM_INPUT_STREAM(strm)));
-
- case smm_string_input:
- return(sLcharacter);
-
- case smm_string_output:
- return(sLcharacter);
-
- default:
- FEerror("Illegal stream mode for ~S.",1,strm);
- return(FALSE);
- }
-}
-
void
setup_stream_buffer(object x) {
#ifdef NO_SETBUF
vs_base[0] = Cnil;
}
-LFD(Lstream_element_type)()
-{
- check_arg(1);
-
- check_type_stream(&vs_base[0]);
- vs_base[0] = stream_element_type(vs_base[0]);
-}
-
@(defun close (strm &key abort)
@
check_type_stream(&strm);
make_function("STREAMP", Lstreamp);
make_function("INPUT-STREAM-P", Linput_stream_p);
make_function("OUTPUT-STREAM-P", Loutput_stream_p);
- make_function("STREAM-ELEMENT-TYPE", Lstream_element_type);
make_function("CLOSE", Lclose);
/* make_si_function("OPEN1", Lopen1); */
projects / gcl27.git / commitdiff